(****************************************************)
(*													*)
(*	file:  SimulationToolbox.m						*)
(*													*)
(*  This is the implementation module - see the 	*)
(*	definition module for documentation on external	*)
(*	routines.										*)
(*													*)
(*	Written in SemperSoft Modula-2 v.1.1.2			*)
(*													*)
(*  Allen Stenger	June 1989						*)
(*													*)
(****************************************************)

IMPLEMENTATION MODULE SimulationToolbox;

FROM SYSTEM		IMPORT	ADDRESS,ADR,PROCESS,NEWPROCESS,
						LONG,TRANSFER,TSIZE;
FROM InOut		IMPORT	CloseOutput,OpenOutput;
FROM InOut		IMPORT	Read,WriteCard,WriteLn,
						WriteString;
FROM Storage	IMPORT	ALLOCATE;
FROM InsideMac	IMPORT	DefltStack,GetApplLimit,
						SetApplLimit;
FROM VolumeIV	IMPORT	StackSpace;

TYPE
	SimulationQueue	=	POINTER TO QueueBlock;

VAR
	currentTime	:	Duration;
						(* current simulated time *)

PROCEDURE PrintHalt; FORWARD;

	(************************************************)
	(*												*)
	(*	This local module encapsulates the 			*)
	(*	workspace allocation and deallocation.		*)
	(*												*)
	(************************************************)
	
	MODULE WorkSpaceManager;
	IMPORT WriteString;
	IMPORT PrintHalt;
	EXPORT	AllocateWorkSpace,DeallocateWorkSpace;
	
	(******* temporary implementation with all 
		fixed-size WS of 8192 bytes *)
	TYPE
		WSIndex		=	[1..15];
		WS			=	ARRAY [1..4096] OF INTEGER;
		WSDesc		=	RECORD
							WSArea	:	WS;
							ThisWS,
							NextWS	:	CARDINAL;
						END; (* RECORD *)
		
	VAR
		theWorks	:	ARRAY WSIndex OF WSDesc;
		freeWS		:	CARDINAL;				
							(* chain of free blocks *)
	
	PROCEDURE AllocateWorkSpace( VAR wsp : ADDRESS; 
								 worksize : CARDINAL );
	BEGIN
		IF worksize # TSIZE(WS)
		THEN
			WriteString(">>>wrong size worksize");
			PrintHalt;
		ELSIF freeWS = 0 THEN
			WriteString(">>> Out of workspaces ");
			PrintHalt;
		ELSE
			WITH theWorks[freeWS] DO
				wsp := ADR(WSArea);
				freeWS := NextWS;
			END; (* WITH *)
		END; (* IF *)
	END AllocateWorkSpace;
	
	PROCEDURE DeallocateWorkSpace( wsp : ADDRESS; 
								  worksize : CARDINAL );
	VAR
		i	:	CARDINAL;
	BEGIN
		FOR i := MIN(WSIndex) TO MAX(WSIndex) DO
			WITH theWorks[i] DO
				IF ADR(WSArea) = wsp
				THEN
					NextWS := freeWS;
					freeWS := i;
				END; (* IF *)
			END; (* WITH *)
		END; (* DO *)
	END DeallocateWorkSpace;
	
	PROCEDURE Init;
	VAR
		i	:	CARDINAL;
	BEGIN
		(* Chain the workspaces together *)
		freeWS := MIN(WSIndex);
		FOR i := MIN(WSIndex) TO MAX(WSIndex) DO
			WITH theWorks[i] DO
				ThisWS := i;
				NextWS := i + 1;
			END; (* WITH *)
		END; (* FOR *)
		theWorks[MAX(WSIndex)].NextWS := 0;
	END Init;
	
	BEGIN
		Init;
	END WorkSpaceManager;
	
	(************************************************)
	(*												*)
	(*	This local module encapsulates the TCB 		*)
	(*	(Thread Control Block) and does most of the *)
	(*	work of the Toolbox.  References to TCBs 	*)
	(*	should pass the TCB (pointer) to this 		*)
	(*	package, and should not	reference TCB 		*)
	(*	fields directly.							*)
	(*												*)
	(************************************************)

	MODULE TCBManager;
	IMPORT	Duration,Starter;
	IMPORT 	WriteString;
	IMPORT	currentTime;
	IMPORT	DeallocateWorkSpace;
	IMPORT 	PrintHalt;
	EXPORT 	TCB,TCBQHdr,
			DispatchFromQueue,AddToReadyQueue,
			CreateNewTCB,HangHalt,HangHold,StartTCB,
			QueueTCB,DequeueTCB;
	
	TYPE
		TCBPtr		=	POINTER TO TCBType;
		TCBType		=	
		RECORD
			NextTCB		:	TCBPtr;	(* forward chain *)
			ThreadNumber:	CARDINAL; (* seq. no. *)
			HaltPending	:	BOOLEAN; 
								(* halt in progress *)
			SuspendPending : BOOLEAN; 
								(* suspend in progress*)
			ActTime		:	Duration; 
								(* when to activate *)
			State		:	PROCESS; (* from TRANSFER *)
			StartProc	:	Starter; (* where to begin*)
			Parms		:	ADDRESS; (* thread parms *)
			WorkSpace	:	ADDRESS; (* stack address *)
			WorkSize	:	CARDINAL; 
								(* stack size in bytes*)
		END; (* RECORD *)
						
		TCB			=	TCBPtr;		
						(* for export only - in this 
							module use TCBPtr *)
		TCBQHdr		=	TCBPtr;
		TCBRange	=	[1..20];
		
	VAR
		(*  TCB lists -- TCBs may also be queued on 
			SimulationQueue types *)
		currentTCB	: TCBPtr; (* currently active TCB *)
		readyList	: TCBPtr; (* waiting TCBs, 
						in ascending order of ActTime *)
		haltList	: TCBPtr; (* TCBs awaiting halt *)
		freeTCB		: TCBPtr; (* free list of 
									TCB blocks *)
		
		lastThreadNumber : CARDINAL; 
						(* latest 
							TCBPtr^.ThreadNumber *)
		TCBBlocks	: ARRAY TCBRange OF TCBType; 
					 (* TCB pool *)
		
	(*  Dispatch the next TCB from the ready list while 
		queueing the current TCB. *)
	PROCEDURE DispatchFromQueue;
	(*
		This is the "scheduler" for the simulation.  
		When it is called by a thread, in general that 
		thread will be suspended and another will begin 
		running.  More precisely, there are 5 
		possibilities for the calling thread:
			1.	The thread will return after advancing 
				currentTime, without disturbing the 
				ready list.  (Only occurs if the current
				TCB has an earlier activation time that 
				any TCB on the list.)
			2.	The thread is marked to terminate and 
				will dequeue the next TCB from the ready 
				list, place it as the current TCB, 
				advance currentTime, place itself on the
				halt queue, and suspend itself (by 
				TRANSFER to the new current TCB).
			3.	Same as 2 except it places itself in 
				order on the ready list.
			4.	The simulation halts because the current 
				thread is marked to suspend or terminate
				and there are no ready TCBs.
			5.	Same as 2 except the current TCB has 
				already been placed	on a SimulationQueue
				and will not be further touched, except
				to TRANSFER to the next TCB.
		
		When a new thread is selected to be the current 
		thread, there are two possibilities for it:
			A.	It may begin execution at StartTCB (if 
				this is its first execution).
			B.	It may begin execution immediately 
				following the TRANSFER (if it is 
				resuming execution).
		In case B the thread will check the halt queue 
		and release any TCBs on it, then will issue 
		RETURN, causing it to return to the call that 
		send it to the scheduler in the first place.  
		Thus for HOLD the thread has held for the 
		desired time and is now returning to the
		simulation code, and for suspensions execution 
		will resume at the point of suspension.
	*)
		
	VAR
		saveCurrent		:	TCBPtr;
		
		PROCEDURE RequeueTCB( t : TCBPtr );
		VAR
			lastTCB,
			thisTCB			:	TCBPtr;
		BEGIN
			lastTCB := NIL;
			thisTCB := readyList;
			WHILE (thisTCB # NIL) 
				AND (t^.ActTime >= thisTCB^.ActTime) DO
				lastTCB := thisTCB;
				thisTCB := thisTCB^.NextTCB;
			END; (* WHILE *)
			t^.NextTCB := thisTCB;
			IF lastTCB = NIL
			THEN (* inserting at beginning *)
				readyList := t;
			ELSE (* inserting past beginning *)
				lastTCB^.NextTCB := t;
			END; (* IF *)
		END RequeueTCB;
		
		PROCEDURE ClearHaltQueue;
		VAR
			releasedTCB		:	TCBPtr;
		BEGIN
			WHILE haltList # NIL DO
				WITH haltList^ DO
					IF WorkSpace # NIL (* main is 
										special - no 
										workspace *)
					THEN
						DeallocateWorkSpace( 
							WorkSpace,WorkSize);
					END; (* IF *)
				END; (* WITH *)
				releasedTCB := haltList;
				haltList := haltList^.NextTCB;
				releasedTCB^.NextTCB := freeTCB;
				freeTCB := releasedTCB;
			END; (* WHILE *)
		END ClearHaltQueue;
		
	BEGIN (* DispatchFromQueue *)
		IF readyList = NIL
		THEN (* no other active threads *)
			IF currentTCB^.SuspendPending 
				OR currentTCB^.HaltPending
			THEN (* case 4 *)
				PrintHalt;
			ELSE (* case 1 with empty ready list *)
				currentTime := currentTCB^.ActTime;
				(* just return *)
			END; (* IF *)
		ELSE (* other active threads - 
				see who gets to run *)
			IF 	currentTCB^.SuspendPending
				OR currentTCB^.HaltPending 
				OR (currentTCB^.ActTime >= 
					readyList^.ActTime)
					(* >= ensures that list will be 
					shuffled if other TCBs have the 
					same activation time as currentTCB - 
					needed for CreateNewThread *)
			THEN (* new thread gets to run - 
					cases 5, 2 and 3 *)
				saveCurrent := currentTCB;
				currentTCB := readyList;
				readyList := readyList^.NextTCB;
				currentTime := currentTCB^.ActTime;
				
				IF saveCurrent^.SuspendPending
				THEN (* no queueing action required - 
						case 5 *)
					saveCurrent^.SuspendPending :=
						FALSE;
				ELSIF saveCurrent^.HaltPending
				THEN (* put on halt queue - case 2 *)
					saveCurrent^.NextTCB := haltList;
					haltList := saveCurrent;
				ELSE (* put on ready list - case 3 *)
					RequeueTCB(saveCurrent);
				END; (* IF *)
				
				(*****************************)
				TRANSFER(	saveCurrent^.State,
							currentTCB^.State);
				(*****************************)
				
				(* new thread is now in control *)
				
				ClearHaltQueue;
				
			ELSE (* old thread continues - 
					case 1 with non-empty ready list*)
				currentTime := currentTCB^.ActTime;
				(* just return *)
			END; (* IF *)
		END; (* IF *)
	END DispatchFromQueue;
	
	(*	Add a TCB to the beginning of the ready list *)
	PROCEDURE AddToReadyQueue( t : TCBPtr );
	BEGIN
		t^.ActTime := currentTime;
		t^.NextTCB := readyList;
		readyList := t;
	END AddToReadyQueue;
	
	(*	Allocate a new TCB.  Note that only the pointer 
		is returned - the caller has no direct access 
		to TCBs but should go through this module.  The 
		workspace address and size are recorded in the 
		TCB for use when the TCB exits.  *)
	PROCEDURE CreateNewTCB ( 	VAR t : TCBPtr;
								p : PROCESS; 
								startP : Starter;
								parms : ADDRESS;
								workspace : ADDRESS;
								worksize : CARDINAL );
	BEGIN
		IF freeTCB = NIL
		THEN
			WriteString(">>>Out of TCBs");
			PrintHalt;
		ELSE
			t := freeTCB;
			freeTCB := freeTCB^.NextTCB;
			WITH t^ DO
				NextTCB := NIL;
				INC(lastThreadNumber);
				ThreadNumber := lastThreadNumber;
				HaltPending := FALSE;
				SuspendPending := FALSE;
				ActTime	:= currentTime;
				State := p;
				StartProc := startP;
				Parms := parms;
				WorkSpace := workspace;
				WorkSize := worksize;
			END; (* WITH *)
		END; (* IF *)
	END CreateNewTCB;
	
	(*  Mark the current TCB to be halted.  It will 
		continue to run until DispatchFromQueue is 
		called next, at which point the TCB will be 
		placed on the halt queue. *)
	PROCEDURE HangHalt;
	BEGIN
		currentTCB^.HaltPending := TRUE;
	END HangHalt;
	
	(*	Mark the current TCB to run again after a 
		specified Duration.  It will continue to run 
		until DispatchFrom Queue is called.  *)
	PROCEDURE HangHold ( howLong : Duration );
	BEGIN
		currentTCB^.ActTime := currentTime + howLong;
	END HangHold;
	
	(*  Begin execution of a new thread according to 
		starter in TCB.  This is activated as a result 
		of the TRANSFER in DispatchFromQueue the first 
		time the thread runs.  *)
	PROCEDURE StartTCB;
	BEGIN
		WITH currentTCB^ DO
			StartProc(Parms);
		END; (* WITH *)
	END StartTCB;
	
	(* 	Add the current TCB to a user queue, or remove 
		a TCB from a user queue.  A parameter block 
		address is recorded, then returned when the TCB 
		is dequeued. *)
		
	PROCEDURE QueueTCB( qParm : ADDRESS; 
						VAR qHdr : TCBQHdr ); 
	VAR
		lastTCB	:	TCB;
	BEGIN
		IF qHdr = NIL
		THEN (* only item in queue *)
			qHdr := currentTCB;
		ELSE (* add after last element in queue *)
			lastTCB := qHdr;
			WHILE lastTCB^.NextTCB # NIL DO
				lastTCB := lastTCB^.NextTCB;
			END; (* WHILE *)
			lastTCB^.NextTCB := currentTCB;
		END; (* IF *)
		WITH currentTCB^ DO
			NextTCB := NIL;
			Parms := qParm;	
			SuspendPending := TRUE;
		END; (* WITH *)
	END QueueTCB;
	
	PROCEDURE DequeueTCB( 	VAR t : TCB; 
							VAR qParm : ADDRESS; 
							VAR qHdr : TCBQHdr ); 
	BEGIN
		t := qHdr;
		qHdr := qHdr^.NextTCB;
		qParm := t^.Parms;
	END DequeueTCB;
	
	
	PROCEDURE Init;
	VAR
		i			:	CARDINAL; (* loop control *)
		dummyProc	:	Starter; (* just used for main*)
	BEGIN
		readyList := NIL;
		haltList := NIL;
		freeTCB := NIL;
		
		FOR i := MIN(TCBRange) TO MAX(TCBRange) DO
			TCBBlocks[i].NextTCB := freeTCB;
			freeTCB := ADR(TCBBlocks[i]);
		END; (* FOR *)
		
		lastThreadNumber := 0;
		
		(* initialize TCB for already-running 
			main routine *)
		CreateNewTCB(currentTCB,PROCESS(0),
						dummyProc,ADDRESS(0),
						ADDRESS(0),0);
		
	END Init;
	
	BEGIN (* TCBManager *)
		Init;
	END TCBManager;
	
(****************************************************)
(*													*)
(*	Miscellaneous outer-level routines				*)
(*													*)
(****************************************************)

PROCEDURE PrintHalt;
VAR
	ch	:	CHAR;
BEGIN
	WriteLn;
	WriteLn;
	WriteString(">>> Simulation halting at time ");
	WriteCard( currentTime,6 );
	WriteLn;
	CloseOutput;
	
	WriteString(">>> Simulation halting at time ");
	WriteCard( currentTime,6 );
	WriteLn;
	WriteString(">>> Press any key to end ");
	Read( ch );
	HALT;
END PrintHalt;

(*  This routine expands the stack after the workspaces
	are allocated to ensure that the Color QuickDraw
	text-drawing routines have enough stack to run. *)
PROCEDURE EnsureEnoughStack;
VAR
	moreThanEnough	:	LONGINT; (* excess over 
									default *)
BEGIN
	moreThanEnough := StackSpace() - DefltStack;
	IF moreThanEnough < 0
	THEN SetApplLimit( 
				GetApplLimit() + moreThanEnough );
	END; (* IF *)
END EnsureEnoughStack;

(****************************************************)
(*													*)
(*	Externally visible routines - see definition 	*)
(*	module for documentation.						*)
(*													*)
(****************************************************)

PROCEDURE CreateNewThread( 	starter : Starter; 
							parameterAddress : ADDRESS;
							worksize : CARDINAL );
VAR
	newTCB			:	TCB;
	wsp				:	ADDRESS;
	threadProcess	:	PROCESS;
BEGIN
	AllocateWorkSpace(wsp, worksize);
	NEWPROCESS(	StartTCB,wsp,LONG(worksize),
				threadProcess);
	CreateNewTCB(newTCB,threadProcess,
					starter,parameterAddress,wsp,
					worksize);
	AddToReadyQueue(newTCB);
	DispatchFromQueue;
END CreateNewThread;
						
PROCEDURE Hold( howLong : Duration );
BEGIN
	HangHold( howLong );
	DispatchFromQueue;
END Hold;

PROCEDURE HaltSimulation;
BEGIN
	PrintHalt;		(* A Quick and Dirty Production *)
END HaltSimulation;

PROCEDURE HaltThread;
BEGIN
	HangHalt;
	DispatchFromQueue;
END HaltThread;

PROCEDURE CurrentTime() : Duration;
BEGIN
	RETURN currentTime;
END CurrentTime;

(****************************************************)
(*	Queueing routines								*)
(****************************************************)

(* External definitions for queueing *)
TYPE
	QueueBlock	=	RECORD
						Orders	:	TCBQHdr;
							(* waiters for service *)
						Servers	:	TCBQHdr;	
							(* providers of service *)
					END; (* RECORD *)
	Requester		=	TCB;


PROCEDURE InitializeQueue( VAR q : SimulationQueue );
BEGIN
	NEW( q );
	q^.Orders := NIL;
	q^.Servers := NIL;
END InitializeQueue;

PROCEDURE PlaceOrder( 	q : SimulationQueue; 
						parameterAddress : ADDRESS );
VAR
	s		:	TCB; (* server which is activated 
						by this order *)
	trash	:	ADDRESS;
BEGIN
	QueueTCB( parameterAddress, q^.Orders );
	IF q^.Servers = NIL
	THEN (* have to wait *)
	ELSE (* activate server for this queue *)
		DequeueTCB( s, trash, q^.Servers );
		AddToReadyQueue( s );
		(* the server will run and dequeue this order *)
	END; (* IF *)
	DispatchFromQueue;
END PlaceOrder;

PROCEDURE Serve( q: SimulationQueue; 
				VAR parameterAddress : ADDRESS; 
				VAR r : Requester );
BEGIN
	IF q^.Orders = NIL
	THEN (* have to wait for order *)
		QueueTCB( NIL, q^.Servers );
		DispatchFromQueue; (* wait for order *)
	END; (* IF *)
	(* 	either resume execution after order arrives, or
		continue without wait if order already 
		available *)
	DequeueTCB( r, parameterAddress, q^.Orders);
END Serve;

PROCEDURE Reactivate( r : Requester );
BEGIN
	AddToReadyQueue( r );
END Reactivate;


BEGIN (* SimulationToolbox *)
	currentTime := 0;
	EnsureEnoughStack;
	OpenOutput("Enter file name for logging:");
END SimulationToolbox.